home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / you-075a.lha / you-075a / error.c < prev    next >
C/C++ Source or Header  |  1992-07-22  |  22KB  |  740 lines
  1. /* ******************************************************************** */
  2. /*  error.c          Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* Error and Signal handling                                            */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: error.c,v 1.13 1992/07/22 15:35:05 pab Exp $
  9.  *
  10.  * $Log: error.c,v $
  11.  * Revision 1.13  1992/07/22  15:35:05  pab
  12.  * corrected fn_signal
  13.  *
  14.  * Revision 1.12  1992/06/27  05:04:42  kjp
  15.  * False alarm but added this RCS header so it wasn't a complete loss...
  16.  *
  17.  *
  18.  */
  19.  
  20. /*
  21.  * Change Log:
  22.  *   Version 1, April 1989
  23.  *    Added names of the defined conditions - JPff
  24.  *   Version 2, May 1989
  25.  *    Amalgamated with section condition.c for sanity
  26.  *   Version 3, May 1989
  27.  *      Updated for new ideas on handlers/restarts - RJB
  28.  *      Integrated conditions into the object system - KJP
  29.  *   Version 4, June 1990
  30.  *      Rewrote handlers and signals correctly - KJP
  31.  *        - with-handler special 
  32.  *        - generally rearranged 
  33.  */
  34.  
  35. #include <stdio.h>
  36. #include <string.h>
  37. #include "defs.h"
  38. #include "structs.h"
  39. #include "funcalls.h"
  40.  
  41. #include "global.h"
  42. #include "error.h"
  43.  
  44. #include "bootstrap.h"
  45. #include "slots.h"
  46. #include "class.h"
  47.  
  48. #include "symboot.h"
  49. #include "modules.h"
  50. #include "specials.h"
  51. #include "modboot.h"
  52. #include "ngenerics.h"
  53. #include "calls.h"
  54.  
  55. #include "state.h"
  56.  
  57. #define N_SLOTS_IN_CONDITION 2
  58. /* The error system classes... */
  59.  
  60. LispObject Condition_Class; 
  61. LispObject Default_Condition;
  62.  
  63. /* Array for pre-defind conditions... */
  64.  
  65. LispObject defined_conditions; /* a vector of junk */
  66.  
  67. extern LispObject unbound;
  68.  
  69. /*
  70.  * Conditions...
  71.  * Includes generation and defined slot access... 
  72.  */
  73.  
  74. /* Predicate... */
  75.  
  76. EUFUN_1( Fn_conditionp, form)
  77. {
  78.   return (is_condition(form) ? lisptrue : nil);
  79. }
  80. EUFUN_CLOSE
  81.  
  82. /* Generator... */
  83.  
  84. EUFUN_2( Fn_make_condition, class, initlist)
  85. {
  86.   LispObject ans;
  87.   
  88.   EUCALLSET_2(ans, Fn_subclassp, classof(class),Condition_Class);
  89.   if (ans==nil)
  90.     CallError(stackbase, "make-condition: non condition class",
  91.           ARG_0(stackbase),NONCONTINUABLE);
  92.  
  93.   return(Gf_make_instance(stackbase));
  94.  
  95. }
  96. EUFUN_CLOSE
  97.  
  98. /*
  99.  
  100.  * Built in condition slot accessors...
  101.  
  102. */
  103.  
  104. EUFUN_1( Fn_condition_name, cond)
  105. {
  106.  
  107.   if (!is_condition(cond))
  108.     CallError(stackbase,"condition-name: not a condition",cond,NONCONTINUABLE);
  109.  
  110.   return classof(cond)->CLASS.name;
  111. }
  112. EUFUN_CLOSE
  113.  
  114. EUFUN_1( Fn_condition_message, cond)
  115. {
  116.  
  117.   if (!is_condition(cond))
  118.     CallError(stackbase,
  119.           "condition-message: not a condition",cond,NONCONTINUABLE);
  120.  
  121.   return(condition_message(cond));
  122. }
  123. EUFUN_CLOSE
  124.  
  125. EUFUN_1( Fn_condition_error_value, cond)
  126. {
  127.  
  128.   if (!is_condition(cond))
  129.     CallError(stackbase,
  130.           "condition-error-value: not a condition",cond,NONCONTINUABLE);
  131.  
  132.   return(condition_error_value(cond));
  133. }
  134. EUFUN_CLOSE
  135.  
  136. /* 
  137.  * Signals and Handlers...
  138.  */
  139.  
  140. /* Heap collapse... */
  141.  
  142. void signal_heap_failure(LispObject *stackbase, int type)
  143. {
  144.   extern LispObject Fn_abort_thread(LispObject*);
  145.   extern LispObject interpreter_thread;
  146.   extern LispObject read_eval_print_continue;
  147.   
  148.   fprintf(StdErr->STREAM.handle,
  149.       "\nTrapping heap exhaustion condition on type %x\n\n",type);
  150.   
  151. #ifndef MACHINE_ANY
  152.  
  153.   if (CURRENT_THREAD() == CAR(interpreter_thread)) {
  154.     fprintf(StdErr->STREAM.handle,
  155.         "Calculation abandoned - returning to top level...\n\n");
  156.     call_continue(stackbase,CAR(read_eval_print_continue),lisptrue);
  157.   }
  158.  
  159.   fprintf(StdErr->STREAM.handle,
  160.       "Thread aborting - wait for other failures...\n\n");
  161.   (void) Fn_abort_thread(stackbase);
  162.  
  163. #else
  164.  
  165.   fprintf(StdErr->STREAM.handle,
  166.       "Calculation abandoned - returning to top level...\n\n");
  167.   call_continue(stackbase,CAR(read_eval_print_continue),lisptrue);
  168.  
  169. #endif
  170. }
  171.  
  172. /* Prompt string... */
  173.  
  174. #define MAX_PROMPT_LENGTH (1024)
  175. char current_prompt_string[MAX_PROMPT_LENGTH];
  176.   
  177. /* Default signal handling... */
  178.  
  179. static LispObject sym_pling_backtrace;
  180. static LispObject sym_pling_b;
  181. static LispObject sym_pling_quickie;
  182. static LispObject sym_pling_q;
  183. LispObject sym_pling_exit; 
  184. LispObject sym_pling_root;
  185.  
  186. extern LispObject Gf_generic_write(LispObject*);
  187.  
  188. void condition_handler(LispObject *stackbase, LispObject cond,LispObject cont)
  189. {
  190.   extern 
  191.     SYSTEM_THREAD_SPECIFIC_DECLARATION(int,system_scheduler_number);
  192.   extern 
  193.     LispObject Gf_generic_prin(LispObject*);
  194.   extern
  195.     void module_eval_backtrace(LispObject *);
  196.   extern
  197.     void quickie_module_eval_backtrace(LispObject *);
  198.   extern
  199.     LispObject get_history_form(LispObject);
  200.   extern
  201.     void put_history_form(LispObject*, LispObject);
  202.   extern
  203.     int get_history_count(void);
  204.  
  205.   LispObject *stacktop = stackbase;
  206.   LispObject form,value;
  207.   LispObject *gc_index = GC_STACK_POINTER();
  208.  
  209.   while (TRUE) {
  210.     sprintf(current_prompt_string,"eulisp-handler:%x:%s!%d> ",
  211.         SYSTEM_THREAD_SPECIFIC_VALUE(system_scheduler_number),
  212.         stringof(SYSTEM_GLOBAL_VALUE(current_interactive_module)
  213.              ->I_MODULE.name->SYMBOL.pname),
  214.         get_history_count());
  215. /*
  216.     fprintf(StdErr->STREAM.handle,"eulisp-handler:%x:",
  217.         SYSTEM_THREAD_SPECIFIC_VALUE(system_scheduler_number));
  218.     EUCALL_2(Gf_generic_prin,
  219.              SYSTEM_GLOBAL_VALUE(current_interactive_module)->I_MODULE.name,
  220.          StdErr);
  221.     fprintf(StdErr->STREAM.handle,"!%d> ",get_history_count());
  222. */
  223.  
  224. #ifndef GNUREADLINE
  225.     fprintf(StdErr->STREAM.handle,"%s",current_prompt_string);
  226. #endif
  227.  
  228.     EUCALLSET_1(form, Fn_read, StdIn);
  229.     form = get_history_form(form);
  230.     put_history_form(stacktop, form);
  231.  
  232.     if (form == sym_pling_exit || form == q_eof) return;
  233.     if (form == sym_pling_root) {
  234.       SYSTEM_GLOBAL_VALUE(current_interactive_module) =
  235.     get_module(stacktop,sym_root);
  236.       value = nil;
  237.     } 
  238.     else if (form == sym_pling_backtrace || form == sym_pling_b) {
  239.       module_eval_backtrace(stacktop);
  240.       value = nil;
  241.     }
  242.     else if (form == sym_pling_quickie || form == sym_pling_q) {
  243.       quickie_module_eval_backtrace(stacktop);
  244.       value = nil;
  245.     }
  246.     else
  247.       EUCALLSET_2(value,process_top_level_form,
  248.            SYSTEM_GLOBAL_VALUE(current_interactive_module),
  249.            form);
  250.  
  251.     fprintf(StdErr->STREAM.handle,"eulisp-handler:%x:",
  252.         SYSTEM_THREAD_SPECIFIC_VALUE(system_scheduler_number));
  253.     STACK_TMP(value);
  254.     EUCALL_2(Gf_generic_prin, SYSTEM_GLOBAL_VALUE(current_interactive_module)
  255.            ->I_MODULE.name,StdErr);
  256.     fprintf(StdErr->STREAM.handle,"!%d< ",get_history_count()-1);
  257.  
  258.     UNSTACK_TMP(value);
  259.     EUCALL_2(Gf_generic_write,value,StdErr);
  260.     fprintf(StdErr->STREAM.handle,"\n\n");
  261.   }
  262. }
  263.  
  264. LispObject function_bootstrap_handler;
  265. EUFUN_2( Fn_bootstrap_handler, cond, cont)
  266. {
  267.   LispObject slots;
  268.  
  269.   /* Check for dumb errors... */
  270.  
  271.   if (!is_condition(cond))
  272.     CallError(stackbase,
  273.           "Default Handler not given a condition",cond,NONCONTINUABLE);
  274.  
  275.   if (!is_continue(cont) && cont != nil)
  276.     CallError(stackbase,"Invalid continuation in default handler",cont,
  277.           NONCONTINUABLE);
  278.  
  279.   /* Now, display error message... */
  280.  
  281.   fprintf(stderr,"\nCompiled Elvira initialisation code error!!!\n"); 
  282.  
  283.   fprintf(stderr,"\nTrapping unhandled "); 
  284.   if (cont == nil)
  285.     fprintf(stderr,"non-continuable \"");
  286.   else
  287.     fprintf(stderr,"continuable \"");
  288.  
  289.   fprintf(stderr,"error\"");
  290.   fprintf(stderr,"Check for initcode module --- It is needed\n");
  291.   system_lisp_exit(1);
  292.   
  293.   return(nil);            /* dummy return */
  294. }
  295. EUFUN_CLOSE
  296.  
  297. LispObject function_default_handler;
  298. EUFUN_2( Fn_default_handler, cond, cont)
  299. {
  300.   LispObject slots;
  301.  
  302.   /* Check for dumb errors... */
  303.  
  304.   if (!is_condition(cond))
  305.     CallError(stackbase,
  306.           "Default Handler not given a condition",cond,NONCONTINUABLE);
  307.  
  308.   if (!is_continue(cont) && cont != nil)
  309.     CallError(stackbase,"Invalid continuation in default handler",cont,
  310.           NONCONTINUABLE);
  311.  
  312.   /* Now, display error message... */
  313.  
  314.   /* Should check if it's a heap error... */
  315.  
  316.   fprintf(stderr,"\nTrapping unhandled "); 
  317.   if (cont == nil)
  318.     fprintf(stderr,"non-continuable \"");
  319.   else
  320.     fprintf(stderr,"continuable \"");
  321.   EUCALL_2(Gf_generic_write,classof(cond)->CLASS.name,StdErr);
  322.   fprintf(stderr,"\"\n\n");
  323.   cond = ARG_0(stackbase);
  324.   if (condition_message(cond) != nil) {
  325.     fprintf(stderr,"message: ");
  326.     EUCALL_2(Gf_generic_write,condition_message(cond),StdErr);
  327.     fprintf(stderr,"\n");
  328.     cond = ARG_0(stackbase);
  329.   }
  330.   if (condition_error_value(cond) != unbound) {
  331.     fprintf(stderr,"error-value: ");
  332.     EUCALL_2(Gf_generic_write,condition_error_value(cond),StdErr);
  333.     fprintf(stderr,"\n");
  334.     cond = ARG_0(stackbase);
  335.   }
  336.  
  337.   /* Display the slot contents with names */
  338.  
  339.   if (cond->CLASS.slot_table != nil) {
  340.     EUCALLSET_1(slots, Fn_class_slot_descriptions,classof(cond));
  341.     while (slots != nil) {
  342.       extern LispObject generic_slot_value_using_slot_description;
  343.       LispObject xx;
  344.  
  345.       LispObject desc = CAR(slots);
  346.  
  347.       slots = CDR(slots);
  348.       STACK_TMP(slots); STACK_TMP(desc);
  349.       EUCALLSET_1(xx, Fn_slot_description_name, desc);
  350.       EUCALL_2(Gf_generic_write, xx,StdErr);
  351.       fprintf(stderr,": ");
  352.       UNSTACK_TMP(desc);
  353.       cond = ARG_0(stackbase);
  354.       xx = generic_apply_2(stacktop,
  355.                generic_slot_value_using_slot_description,
  356.                cond, desc);
  357.       EUCALL_2(Gf_generic_write,xx,StdErr);
  358.       fprintf(stderr,"\n");
  359.       UNSTACK_TMP(slots);
  360.     }
  361.   }
  362.  
  363.   fprintf(StdErr->STREAM.handle,"\n");
  364.   fflush(StdIn->STREAM.handle);
  365.  
  366.   {
  367.     extern void module_eval_backtrace(LispObject *);
  368.     extern LispObject Fn_abort_thread(LispObject *);
  369.     extern LispObject read_eval_print_continue;
  370.     extern LispObject interpreter_thread;
  371.     extern void call_continuation(LispObject*,LispObject,LispObject);
  372.  
  373.     /* Go for auto-backtrace on weird threads */
  374.  
  375.     cond = ARG_0(stackbase);
  376.     cont = ARG_1(stackbase);
  377.     if (CURRENT_THREAD() == CAR(interpreter_thread)) {
  378.       fprintf(StdErr->STREAM.handle,"Entering condition handler...\n\n");
  379.       condition_handler(stacktop,cond,cont);
  380.       fprintf(StdErr->STREAM.handle,"\nReturning to top level...\n\n");
  381.       call_continuation(stacktop,CAR(read_eval_print_continue),nil);
  382.     }
  383. #ifndef MACHINE_ANY
  384.     
  385.     fprintf(StdErr->STREAM.handle,"ABORTING THREAD: ");
  386.     EUCALL_2(Gf_generic_write,CURRENT_THREAD(),StdErr);
  387.     fprintf(StdErr->STREAM.handle,"\n\nBacktrace follows...\n");
  388.     module_eval_backtrace(stacktop);
  389.     fprintf(StdErr->STREAM.handle,"Thread aborted.\n\n");
  390.     (void) Fn_abort_thread(stacktop);
  391.  
  392. #endif
  393.  
  394.   }
  395.  
  396.   return(nil);            /* dummy return */
  397. }
  398. EUFUN_CLOSE
  399.  
  400. /* User signal function... */
  401.  
  402. EUFUN_2( Fn_signal, cond, cont)
  403. {
  404.   LispObject stack;
  405.  
  406.   if (cont != nil && !is_continue(cont))
  407.     CallError(stackbase,"signal: non continuation",cont,NONCONTINUABLE);
  408.  
  409.   if (!is_condition(cond))
  410.     CallError(stackbase,"signal: not a condition",cond,NONCONTINUABLE);
  411.  
  412.   /* OK, grab a handler and do the business... */
  413.  
  414.   /* Here be strangeness - handlers are executed in the handler environment
  415.      of their establishment => (I think) just decrementing the handler stack
  416.      as we run along - continuations will re-instate, but keep a copy for
  417.      GC safety... */
  418.  
  419.   stack = HANDLER_STACK();
  420.  
  421.   STACK_TMP(stack);
  422.   
  423.   while (is_cons(HANDLER_STACK())) {
  424.     LispObject handle;
  425.  
  426.     handle = CAR(HANDLER_STACK()); 
  427.     HANDLER_STACK() = CDR(HANDLER_STACK());
  428.  
  429.     /* Need this 'cos apply allocates... */
  430.     
  431.     if (handle == function_default_handler)
  432.       EUCALL_2(Fn_default_handler,cond,cont);
  433.     else
  434.       EUCALL_3(apply2,handle,cond,cont);
  435.     cond = ARG_0(stackbase);
  436.     cont = ARG_1(stackbase);
  437.  
  438.     /* Back here means try again... */
  439.   }
  440.  
  441.   /* Ack! No handler accepted!! */
  442.   EUCALL_2(Fn_default_handler,cond,cont);
  443. #ifdef old /* Mon Jul  6 10:56:55 1992 */
  444. /**/
  445. /**/  UNSTACK_TMP(stack);
  446. /**/
  447. /**/  HANDLER_STACK() = stack;
  448. #endif /* old Mon Jul  6 10:56:55 1992 */
  449.  
  450.   return(cond);
  451. }
  452. EUFUN_CLOSE
  453.  
  454. /*
  455.  * Internally used error handling and signalling...
  456.  */
  457.  
  458. /* Signal condition i with message and one value... */
  459.  
  460. /* Emergency heap condition... */
  461.  
  462. LispObject condition_heap_exhausted;
  463.  
  464. void signal_message(LispObject *stackbase, int i,char *message,LispObject val)
  465. {
  466.   LispObject cond_class;
  467.   LispObject cond;
  468.   LispObject *stacktop = stackbase;
  469.   STACK_TMP(val);
  470.  
  471.   /* Special case if out of heap... */
  472.  
  473.   if (i == HEAP_EXHAUSTED) {
  474.     cond = condition_heap_exhausted;
  475.     fprintf(StdErr->STREAM.handle,"Heap wimped out!! Rats.\n");
  476.     system_lisp_exit(1);
  477.   }
  478.   else {
  479.     cond_class = vref(defined_conditions,i)->SYMBOL.lvalue;
  480.     cond = (LispObject) allocate_instance(stacktop,cond_class);
  481.   }
  482.   STACK_TMP(cond);
  483.   condition_message(cond) = 
  484.     (LispObject) allocate_string(stacktop,message,strlen(message));
  485.   UNSTACK_TMP(cond);
  486.   UNSTACK_TMP(val);
  487.   condition_error_value(cond) = val;
  488.  
  489.   STACK_TMP(cond);
  490.   EUCALL_2(Fn_signal,cond,nil);
  491.   UNSTACK_TMP(cond);
  492.  
  493.   /* Returned => call default... */
  494.  
  495.   EUCALL_2(Fn_default_handler,cond,nil);
  496.  
  497.   /* Returned means deep trouble... */
  498.  
  499.   fprintf(stderr,"INTERNAL ERROR: signal returned on internal call\n");
  500.   fprintf(stderr,"Message was: '%s'\n",message); fflush(stderr);
  501.  
  502.   system_lisp_exit(1);
  503. }
  504.  
  505.  
  506. LispObject CallError(LispObject *stackbase, char *format,LispObject x,int type)
  507. {
  508.   IGNORE(type);
  509.  
  510.   signal_message(stackbase, INTERNAL_ERROR,format,x);
  511.   return(nil);
  512. }
  513.  
  514. EUFUN_3( Fn_cerror, message, cond, args)
  515. {
  516.   LispObject cont,val;
  517.  
  518.   cont = (LispObject) allocate_continue(stackbase);
  519.  
  520.   if (set_continue(stacktop,cont)) return(cont->CONTINUE.value);
  521.  
  522.   STACK_TMP(cont);
  523.   message = ARG_0(stackbase);
  524.   args = ARG_2(stackbase);
  525.   EUCALLSET_2(message, Fn_cons, message, args);
  526.   EUCALLSET_2(message, Fn_cons, sym_message, message);
  527.   cond = ARG_1(stackbase);
  528.   EUCALLSET_2(message, Fn_make_condition, cond, message);
  529.   UNSTACK_TMP(cont);
  530.   EUCALLSET_2(val, Fn_signal, message, cont);
  531.   call_continue(stacktop,cont,val);
  532.   return(val);
  533. }
  534. EUFUN_CLOSE
  535.  
  536. EUFUN_3( Fn_error, message, cond, args)
  537. {
  538.   LispObject val;
  539.  
  540.   EUCALLSET_2(message, Fn_cons, message, args);
  541.   EUCALLSET_2(message, Fn_cons, sym_message, message);
  542.   cond = ARG_1(stackbase);
  543.   EUCALLSET_2(message, Fn_make_condition, cond, message);
  544.   EUCALLSET_2(val, Fn_signal, message, nil);
  545.   return(val);
  546. }
  547. EUFUN_CLOSE
  548.  
  549. /* *************************************************************** */
  550. /* Initialisation of this section                                  */
  551. /* *************************************************************** */
  552.  
  553. #define ERRORS_ENTRIES 10
  554. MODULE Module_errors;
  555. LispObject Module_errors_values[ERRORS_ENTRIES];
  556.  
  557. void initialise_error(LispObject *stacktop)
  558. {
  559.  
  560.   static char* inits[] = {
  561.     "Internal-Error",        /* INTERNAL_ERROR */
  562.  
  563.     "unbound-lexical-variable",    /* UNBOUND_LEXICAL_VARIABLE */
  564.     "unbound-dynamic-variable",    /* UNBOUND_DYNAMIC_VARIABLE */
  565.     "invalid-operator",        /* INVALID_OPERATOR */
  566.     "no-update-function",    /* NO_UPDATE_FUNCTION */
  567.     "immutable-binding",    /* IMMUTABLE_BINDING */
  568.     "no-block-for-return",    /* NO_BLOCK_FOR_RETURN */
  569.     "no-catch-for-throw",    /* NO_CATCH_FOR_THROW */
  570.  
  571.     "clock-tick",        /* CLOCK_TICK */
  572.     "dead-continuation",    /* DEAD_CONTINUATION */
  573.     "dead-thread",        /* DEAD_THREAD */
  574.     "thread-overflow",        /* THREAD_OVERFLOW */
  575.     "thread-underflow",        /* THREAD_UNDERFLOW */
  576.  
  577.     "cannot-make-array",    /* CANNOT_MAKE_ARRAY */
  578.     "cannot-make-character",    /* CANNOT_MAKE_CHARACTER */
  579.     "cannot-make-character_set", /* CANNOT_MAKE_CHARACTER_SET */
  580.     "cannot-make-float",    /* CANNOT_MAKE_FLOAT */
  581.     "cannot-make-number",    /* CANNOT_MAKE_NUMBER */
  582.     "cannot-make-pair",        /* CANNOT_MAKE_PAIR */
  583.     "cannot-make-readtable",    /* CANNOT_MAKE_READTABLE */
  584.     "cannot-make-stream",    /* CANNOT_MAKE_STREAM */
  585.     "cannot-make-string",    /* CANNOT_MAKE_STRING */
  586.     "cannot-make-symbol",    /* CANNOT_MAKE_SYMBOL */
  587.     "cannot-make-table",    /* CANNOT_MAKE_TABLE */
  588.     "cannot-make-thread",    /* CANNOT_MAKE_THREAD */
  589.  
  590.     "floating-overflow",    /* FLOATING_OVERFLOW */
  591.     "floating-underflow",    /* FLOATING_UNDERFLOW */
  592.     "integer-overflow",        /* INTEGER_OVERFLOW */
  593.     "integer-underflow",    /* INTEGER_UNDERFLOW */
  594.     "not-a-number",        /* NOT_A_NUMBER */
  595.  
  596.     "non-existent-file-or-device", /* NON_EXISTENT_FILE_OR_DEVICE */
  597.     "not-an-input-device",    /* NOT_AN_INPUT_DEVICE */
  598.     "not-an-input-stream",    /* NOT_AN_INPUT_STREAM */
  599.     "not-an-output-device",    /* NOT_AN_OUTPUT_DEVICE */
  600.     "cannot-access-file",    /* CANNOT_ACCESS_FILE */
  601.     "cannot-append-to-device",    /* CANNOT_APPEND_TO_DEVICE */        
  602.  
  603.     "slot-unbound",             /* SLOT_UNBOUND */
  604.     "slot-missing",             /* SLOT_MISSING */
  605.     "bad-slot-index",           /* BAD_SLOT_INDEX */
  606.     "no-lambda-list",           /* NON_LAMBDA_LIST */
  607.     "non-allocatable-object",   /* NON_ALLOCATABLE_OBJECT */
  608.     "no-applicable-method",     /* NO_APPLICABLE_METHOD */
  609.     "non-congruent-lambda-lists", /* NON_CONGRUENT_LAMBDA_LISTS */
  610.  
  611.     "cannot-make-vector",       /* CANNOT_MAKE_VECTOR */
  612.  
  613.     "heap-exhausted",           /* HEAP_EXHAUSTED */
  614.  
  615.     "uninitialized-lexical-variable", /* UNINITIALIZED_LEXICAL_VARIABLE */
  616.     "cannot-assign-variable",    /* CANNOT_ASSIGN_VARIABLE */
  617.     "invalid-operands",        /* INVALID_OPERANDS */
  618.     "immutable-location",    /* IMMUTABLE_LOCATION */
  619.     "cannot-modify-empty-list",    /* CANNOT_MODIFY_EMPTY_LIST */
  620.     "name-clash-in-module",    /* NAME_CLASH_IN_MODULE */
  621.     "cannot-unquote-splice",    /* CANNOT_UNQUOTE_SPLICE */
  622.     "semaphore-already-down",    /* SEMAPHORE_ALREADY_DOWN */
  623.     "cannot-make-function",    /* CANNOT_MAKE_FUNCTION */
  624.     "cannot-make-io-stream",    /* CANNOT_MAKE_IO_STREAM */
  625.     "cannot-make-structure-class", /* CANNOT_MAKE_STRUCTURE_CLASS */
  626.     "cannot-open-path",        /* CANNOT_OPEN_PATH */
  627.     "file-already-exists",    /* FILE_ALREADY_EXISTS */
  628.     "inconsistent-open-options", /* INCONSISTENT_OPEN_OPTIONS */
  629.     "invalid-stream-position",    /* INVALID_STREAM_POSITION */
  630.     "not-an-output-stream",    /* NOT_AN_OUTPUT_STREAM */
  631.     "not-an-io-stream",        /* NOT_AN_IO_STREAM */
  632.     "not-a-character-stream",    /* NOT_A_CHARACTER_STREAM */
  633.     "not-a-binary-stream",    /* NOT_A_BINARY_STREAM */
  634.     "not-a-positionable-stream", /* NOT_A_POSITIONABLE_STREAM */
  635.     "path-does-not-exist",    /* PATH_DOES_NOT_EXIST */
  636.     "stream-not-open",        /* STREAM_NOT_OPEN */
  637.     "non-congruent-lambda-list", /* NON_CONGRUENT_LAMBDA_LIST */
  638.     "no-next-method",        /* NO_NEXT_METHOD */
  639.     "method-in-use",        /* METHOD_IN_USE */
  640.     "invalid-return-continuation", /* invalid-return-continuation */
  641.     "invalid-throw-continuation", /* invalid-throw-continuation */
  642.     "cannot-make-tokeniser",    /* cannot-make-tokeniser */
  643.     "bad-method-class",        /* bad-method-class */
  644.  
  645.     0
  646.   };
  647.   int i;
  648.  
  649.   /* Initialise condition metaclass */
  650.  
  651.   Condition_Class = (LispObject) allocate_class(stacktop,NULL);
  652.   add_root(&Condition_Class);
  653.   make_class( stacktop,
  654.           Condition_Class,
  655.          "condition-class",
  656.           Standard_Class,
  657.           Standard_Class, 0 );
  658.   
  659.   Default_Condition = (LispObject) allocate_class(stacktop,NULL);
  660.   add_root(&Default_Condition);
  661.   make_class( stacktop,
  662.           Default_Condition,
  663.          "condition",
  664.           Condition_Class,
  665.           Object, N_SLOTS_IN_CONDITION);
  666.  
  667.   defined_conditions=allocate_vector(stacktop,99);
  668.   add_root(&defined_conditions);
  669.  
  670.   for (i=0; inits[i]; i++) {
  671.     LispObject cond_class;
  672.     vref(defined_conditions,i) = (LispObject) get_symbol(stacktop,inits[i]);
  673.  
  674.     gen_class(stacktop,&cond_class,inits[i],Condition_Class,
  675.           Default_Condition);
  676.     vref(defined_conditions,i)->SYMBOL.lvalue = cond_class;
  677.  
  678. #if 0
  679.       cond_class = allocate_class(stacktop,Condition_Class);
  680.     cond_class->CLASS.superclasses = EUCALL_2(Fn_cons,Default_Condition,nil);
  681.     Default_Condition->CLASS.subclasses =
  682.       EUCALL_2(Fn_cons,cond_class,Default_Condition->CLASS.subclasses);
  683.     cond_class->CLASS.name = defined_conditions[i];
  684. #endif
  685.  
  686.   }
  687.  
  688.   /* Rig heap failure condition... */
  689.  
  690.   condition_heap_exhausted = 
  691.     (LispObject) 
  692.       allocate_instance(stacktop,
  693.              vref(defined_conditions,HEAP_EXHAUSTED)->SYMBOL.lvalue);
  694.  
  695.   add_root(&condition_heap_exhausted);
  696.   sym_pling_backtrace = get_symbol(stacktop,"!backtrace");
  697.   add_root(&sym_pling_backtrace);
  698.   sym_pling_b = get_symbol(stacktop,"!b");
  699.   add_root(&sym_pling_b);
  700.   sym_pling_quickie = get_symbol(stacktop,"!quickie");
  701.   add_root(&sym_pling_quickie);
  702.   sym_pling_q = get_symbol(stacktop,"!q");
  703.   add_root(&sym_pling_q);
  704.   sym_pling_exit = get_symbol(stacktop,"!exit");
  705.   add_root(&sym_pling_exit);
  706.   sym_pling_root = get_symbol(stacktop,"!root");
  707.   add_root(&sym_pling_root);
  708.  
  709.   open_module(stacktop,
  710.           &Module_errors,
  711.           Module_errors_values,
  712.           "errors",
  713.           ERRORS_ENTRIES);
  714.  
  715.   (void) make_module_function(stacktop,"conditionp",Fn_conditionp,1);
  716.  
  717.   (void) make_module_function(stacktop,"make-condition",Fn_make_condition,-2);
  718.  
  719.   (void) make_module_function(stacktop,"condition-name",Fn_condition_name,1);
  720.   (void) make_module_function(stacktop,"condition-message",Fn_condition_message,1);
  721.   (void) make_module_function(stacktop,"condition-error-value",
  722.                   Fn_condition_error_value,1);
  723.  
  724.   (void) make_module_function(stacktop,"signal",Fn_signal,2);
  725.  
  726.   function_bootstrap_handler
  727.     = make_unexported_module_function(stacktop,"bootstrap-handler",
  728.                       Fn_bootstrap_handler,2);
  729.   add_root(&function_bootstrap_handler);
  730.   function_default_handler 
  731.     = make_unexported_module_function(stacktop,"default-handler",Fn_default_handler,2);
  732.   add_root(&function_default_handler);
  733.  
  734.   (void) make_module_function(stacktop,"error",Fn_error,-3);
  735.   (void) make_module_function(stacktop,"cerror",Fn_cerror,-3);
  736.  
  737.   close_module();
  738. }
  739.  
  740.